home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RUNTIME.ZIP / INTERP.R < prev    next >
Encoding:
Text File  |  1992-02-15  |  40.4 KB  |  1,673 lines
  1. #if !COMPILER
  2. /*
  3.  * File: interp.r
  4.  *  The intepreter proper.
  5.  */
  6.  
  7. #include "../h/opdefs.h"
  8.  
  9. extern fptr fncentry[];
  10.  
  11.  
  12. /*
  13.  * The following code is operating-system dependent [@interp.01]. Declarations.
  14.  */
  15.  
  16. #if PORT
  17. Deliberate Syntax Error
  18. #endif                    /* PORT */
  19.  
  20. #if AMIGA
  21. #if LATTICE
  22. extern int chkbreak;
  23. #endif                    /* LATTICE */
  24. #endif                    /* AMIGA */
  25.  
  26. #if ARM || ATARI_ST || MSDOS || MVS || OS2 || UNIX || VM || VMS
  27.    /* nothing needed */
  28. #endif                    /* ARM || ATARI_ST || ... */
  29.  
  30. #if MACINTOSH
  31. #if MPW
  32. #define CURSORINTERVAL 1000
  33. #endif                    /* MPW */
  34. #endif                                  /* MACINTOSH */
  35.  
  36. /*
  37.  * End of operating-system specific code.
  38.  */
  39.  
  40. #ifdef EventMon
  41. static word linenum;        /* source line number */
  42. static word column;        /* source column number */
  43. static word lastline;        /* last source line number */
  44. static word lastcol;        /* last source column number */
  45. extern FILE *monfile;        /* monitoring file */
  46. #endif                    /* EventMon */
  47. word lastop;            /* Last operator evaluated */
  48.  
  49. /*
  50.  * Istate variables.
  51.  */
  52. struct ef_marker *efp;        /* Expression frame pointer */
  53. struct gf_marker *gfp;        /* Generator frame pointer */
  54. inst ipc;            /* Interpreter program counter */
  55. word *sp = NULL;        /* Stack pointer */
  56.  
  57. #ifdef IconCalling
  58. extern int interp_status;    /* interpreter status */
  59. extern int IDepth;        /* depth of icon_call */
  60. #endif                    /* IconCalling */
  61.  
  62. #ifdef EventMon
  63. extern union {             /* clock ticker -- keep in sync w/ fmonitor.r */
  64.    unsigned short s[4];        /* four counters */
  65.    unsigned long l[2];        /* two longs are easier to check */
  66. } ticker;
  67. extern unsigned long oldtick;    /* previous sum of the two longs */
  68. #endif                    /* EventMon */
  69.  
  70.  
  71. int ilevel;            /* Depth of recursion in interp() */
  72. struct descrip value_tmp;    /* list argument to Op_Apply */
  73.  
  74.  
  75. #ifdef MaxLevel
  76. int maxilevel;            /* Maximum ilevel */
  77. int maxplevel;            /* Maximum &level */
  78. word *maxsp;            /* Maximum interpreter sp */
  79. #endif                    /* MaxLevel */
  80.  
  81. struct descrip eret_tmp;    /* eret value during unwinding */
  82.  
  83. int coexp_act;            /* last co-expression action */
  84.  
  85. #ifdef TraceBack
  86. dptr xargp;
  87. word xnargs;
  88. #endif                    /* TraceBack */
  89.  
  90. /*
  91.  * Macros for use inside the main loop of the interpreter.
  92.  */
  93.  
  94. /*
  95.  * Setup_Op sets things up for a call to the C function for an operator.
  96.  */
  97. #ifdef TraceBack
  98. #define Setup_Op(nargs)  \
  99.    rargp = (dptr)(rsp - 1) - nargs; \
  100.    xargp = rargp; \
  101.    ExInterp;
  102. #else                    /* TraceBack */
  103. #define Setup_Op(nargs)  \
  104.    rargp = (dptr)(rsp - 1) - nargs; \
  105.    ExInterp;
  106. #endif                    /* TraceBack */
  107.  
  108.  
  109. #ifdef EventMon
  110. #define Call_Cond InterpEVVal(lastop,E_Ecall); \
  111.          if ((*(optab[lastop]))(rargp) == A_Resume) goto efail; \
  112.      else {\
  113.      rsp = (word *) rargp + 1;\
  114.      goto return_term;}
  115. #else                    /* EventMon */
  116. #define Call_Cond if ((*(optab[lastop]))(rargp) == A_Resume) goto efail; \
  117.      else {\
  118.      rsp = (word *) rargp + 1;\
  119.          break;}
  120. #endif                    /* EventMon */
  121. /*
  122.  * Call_Gen - Call a generator. A C routine associated with the
  123.  *  current opcode is called. When it when it terminates, control is
  124.  *  passed to C_rtn_term to deal with the termination condition appropriately.
  125.  */
  126. #ifdef EventMon
  127. #define Call_Gen   InterpEVVal(lastop,E_Ecall); \
  128.          signal = (*(optab[lastop]))(rargp); \
  129.      goto C_rtn_term;
  130. #else                    /* EventMon */
  131. #define Call_Gen   signal = (*(optab[lastop]))(rargp); \
  132.      goto C_rtn_term;
  133. #endif                    /* EventMon */
  134.  
  135. /*
  136.  * GetWord fetches the next icode word.  PutWord(x) stores x at the current
  137.  * icode word.
  138.  */
  139. #define GetWord (*ipc.opnd++)
  140. #define PutWord(x) ipc.opnd[-1] = (x)
  141. #define GetOp (word)(*ipc.op++)
  142. #define PutOp(x) ipc.op[-1] = (x)
  143. /*
  144.  * DerefArg(n) dereferences the nth argument.
  145.  */
  146. #define DerefArg(n)   Deref(rargp[n])
  147.  
  148. /*
  149.  * For the sake of efficiency, the stack pointer is kept in a register
  150.  *  variable, rsp, in the interpreter loop.  Since this variable is
  151.  *  only accessible inside the loop, and the global variable sp is used
  152.  *  for the stack pointer elsewhere, rsp must be stored into sp when
  153.  *  the context of the loop is left and conversely, rsp must be loaded
  154.  *  from sp when the loop is reentered.  The macros ExInterp and EntInterp,
  155.  *  respectively, handle these operations.  Currently, this register/global
  156.  *  scheme is only used for the stack pointer, but it can be easily extended
  157.  *  to other variables.
  158.  */
  159.  
  160. #define ExInterp    sp = rsp;
  161. #define EntInterp    rsp = sp;
  162.  
  163. /*
  164.  * Inside the interpreter loop, PushDesc, PushNull, PushAVal, and
  165.  *  PushVal use rsp instead of sp for efficiency.
  166.  */
  167.  
  168. #undef PushDesc
  169. #undef PushNull
  170. #undef PushVal
  171. #undef PushAVal
  172. #define PushDesc(d)   {*++rsp=((d).dword); *++rsp=((d).vword.integr);}
  173. #define PushNull   {*++rsp = D_Null; *++rsp = 0;}
  174. #define PushVal(v)   {*++rsp = (word)(v);}
  175.  
  176. /*
  177.  * The following code is operating-system dependent [@interp.02].  Define
  178.  *  PushAVal for computers that store longs and pointers differently.
  179.  */
  180.  
  181. #if PORT
  182. #define PushAVal(x) PushVal(x)
  183. Deliberate Syntax Error
  184. #endif                    /* PORT */
  185.  
  186. #if AMIGA || ARM || ATARI_ST || MACINTOSH || MVS || UNIX || VM || VMS
  187. #define PushAVal(x) PushVal(x)
  188. #endif                    /* AMIGA || ARM || ATARI_ST || ... */
  189.  
  190. #if MSDOS || OS2
  191. #if HIGHC_386 || ZTC_386 || INTEL_386
  192. #define PushAVal(x) PushVal(x)
  193. #else                    /* HIGHC_386 || ZTC_386 || INTEL_386 */
  194. #define PushAVal(x) {rsp++; \
  195.                stkword.stkadr = (char *)(x); \
  196.                *rsp = stkword.stkint; \
  197.                }
  198. #endif                    /* HIGH_386 || ZTC_386 || INTEL_386 */
  199. #endif                    /* MSDOS || OS2 */
  200.  
  201. /*
  202.  * End of operating-system specific code.
  203.  */
  204.  
  205. #ifdef EventMon
  206. #define InterpEVVal(arg1,arg2)  EVVal(arg1,arg2)
  207. #define InterpEVValD(arg1,arg2) EVValD(arg1,arg2)
  208. #define InterpEVValX(arg1,arg2) EVValX(arg1,arg2)
  209. #define InterpEVTick()          EVTick()
  210. #else                    /* EventMon */
  211. #define InterpEVVal(arg1,arg2)
  212. #define InterpEVValD(arg1,arg2)
  213. #define InterpEVValX(arg1,arg2)
  214. #define InterpEVTick()
  215. #endif                    /* EventMon */
  216. /*
  217.  * The main loop of the interpreter.
  218.  */
  219.  
  220. int interp(fsig,cargp)
  221.  
  222. int fsig;
  223. dptr cargp;
  224.    {
  225.    register word opnd;
  226.    register word *rsp;
  227.    register dptr rargp;
  228.    register struct ef_marker *newefp;
  229.    register struct gf_marker *newgfp;
  230.    register word *wd;
  231.    register word *firstwd, *lastwd;
  232.    word *oldsp;
  233.    int type, signal, args;
  234.    extern int (*optab[])();
  235.    extern int (*keytab[])();
  236.    struct b_proc *bproc;
  237.  
  238. #ifdef TallyOpt
  239.    extern word tallybin[];
  240. #endif                    /* TallyOpt */
  241.  
  242.  
  243.    /*
  244.     * Make a stab at catching interpreter stack overflow.  This does
  245.     * nothing for invocation in a co-expression other than &main.
  246.     */
  247.    if (BlkLoc(k_current) == BlkLoc(k_main) &&
  248.       ((char *)sp + PerilDelta) > (char *)stackend) 
  249.          fatalerr(301, NULL);
  250.  
  251. #ifdef Polling
  252.             if (!pollctr--) {
  253.                pollctr = pollevent();
  254.            if (pollctr == -1) fatalerr(141, NULL);
  255.            }
  256. #endif                    /* Polling */
  257.  
  258.    ilevel++;
  259.  
  260. #ifdef MaxLevel
  261.    if (ilevel > maxilevel)
  262.       maxilevel = ilevel;
  263. #endif                    /* MaxLevel */
  264.  
  265.    EntInterp;
  266.  
  267.    if (fsig == G_Csusp) {
  268.  
  269. #ifdef EventMon
  270.    value_tmp = *(dptr)(rsp - 1);    /* argument */
  271.    Deref(value_tmp);
  272.    InterpEVValD(&value_tmp,E_Bsusp);
  273. #endif                    /* EventMon */
  274.  
  275.  
  276.       oldsp = rsp;
  277.  
  278.       /*
  279.        * Create the generator frame.
  280.        */
  281.       newgfp = (struct gf_marker *)(rsp + 1);
  282.       newgfp->gf_gentype = G_Csusp;
  283.       newgfp->gf_gfp = gfp;
  284.       newgfp->gf_efp = efp;
  285.       newgfp->gf_ipc = ipc;
  286.       rsp += Wsizeof(struct gf_smallmarker);
  287.  
  288.       /*
  289.        * Region extends from first word after the marker for the generator
  290.        *  or expression frame enclosing the call to the now-suspending
  291.        *  routine to the first argument of the routine.
  292.        */
  293.       if (gfp != 0) {
  294.      if (gfp->gf_gentype == G_Psusp)
  295.         firstwd = (word *)gfp + Wsizeof(*gfp);
  296.      else
  297.         firstwd = (word *)gfp + Wsizeof(struct gf_smallmarker);
  298.      }
  299.       else
  300.      firstwd = (word *)efp + Wsizeof(*efp);
  301.       lastwd = (word *)cargp + 1;
  302.  
  303.       /*
  304.        * Copy the portion of the stack with endpoints firstwd and lastwd
  305.        *  (inclusive) to the top of the stack.
  306.        */
  307.       for (wd = firstwd; wd <= lastwd; wd++)
  308.      *++rsp = *wd;
  309.       gfp = newgfp;
  310.       }
  311. /*
  312.  * Top of the interpreter loop.
  313.  */
  314.  
  315.    for (;;) {
  316.  
  317. #ifdef EventMon
  318. #if UNIX
  319.       if (ticker.l[0] + ticker.l[1] != oldtick)
  320.      InterpEVTick();
  321. #endif                    /* UNIX */
  322. #endif                    /* EventMon */
  323.          
  324. #ifdef MaxLevel
  325.       if (sp > maxsp)
  326.      maxsp = sp;
  327. #endif                    /* MaxLevel */
  328.  
  329.       lastop = GetOp;        /* Instruction fetch */
  330.  
  331. #ifdef StackPic
  332.       ExInterp;
  333.       stkdump((int)lastop);
  334.       EntInterp;
  335. #endif                    /* StackPic */
  336.  
  337. /*
  338.  * The following code is operating-system dependent [@interp.03].  Check
  339.  *  for external event.
  340.  */
  341. #if PORT
  342. Deliberate Syntax Error
  343. #endif                    /* PORT */
  344.  
  345. #if AMIGA
  346. #if LATTICE
  347.       ExInterp;
  348.       if (chkbreak > 0)
  349.      chkabort();            /* check for CTRL-C or CTRL-D break */
  350.       EntInterp;
  351. #endif                    /* LATTICE */
  352. #endif                    /* AMIGA */
  353.  
  354. #if ARM || ATARI_ST || MSDOS || MVS || OS2 || UNIX || VM || VMS
  355.    /* nothing to do */
  356. #endif                    /* ARM || ATARI_ST || ... */
  357.  
  358. #if MACINTOSH
  359. #if MPW
  360.    {
  361.    static short cursorcount = CURSORINTERVAL;
  362.    if (--cursorcount == 0) {
  363.       RotateCursor(0);
  364.       cursorcount = CURSORINTERVAL;
  365.       }
  366.    }
  367. #endif                    /* MPW */
  368. #endif                    /* MACINTOSH */
  369.  
  370. /*
  371.  * End of operating-system specific code.
  372.  */
  373.  
  374. #ifdef EventOpCodes
  375.       InterpEVVal(lastop,E_Opcode);
  376. #endif                    /* EventOpCodes */
  377.  
  378.       switch ((int)lastop) {        /*
  379.                  * Switch on opcode.  The cases are
  380.                  * organized roughly by functionality
  381.                  * to make it easier to find things.
  382.                  * For some C compilers, there may be
  383.                  * an advantage to arranging them by
  384.                  * likelihood of selection.
  385.                  */
  386.  
  387.                 /* ---Constant construction--- */
  388.  
  389.      case Op_Cset:        /* cset */
  390.         PutOp(Op_Acset);
  391.         PushVal(D_Cset);
  392.         opnd = GetWord;
  393.         opnd += (word)ipc.opnd;
  394.         PutWord(opnd);
  395.         PushAVal(opnd);
  396.         break;
  397.  
  398.      case Op_Acset:     /* cset, absolute address */
  399.         PushVal(D_Cset);
  400.         PushAVal(GetWord);
  401.         break;
  402.  
  403.      case Op_Int:        /* integer */
  404.         PushVal(D_Integer);
  405.         PushVal(GetWord);
  406.         break;
  407.  
  408.      case Op_Real:        /* real */
  409.         PutOp(Op_Areal);
  410.         PushVal(D_Real);
  411.         opnd = GetWord;
  412.         opnd += (word)ipc.opnd;
  413.         PushAVal(opnd);
  414.         PutWord(opnd);
  415.         break;
  416.  
  417.      case Op_Areal:     /* real, absolute address */
  418.         PushVal(D_Real);
  419.         PushAVal(GetWord);
  420.         break;
  421.  
  422.      case Op_Str:        /* string */
  423.         PutOp(Op_Astr);
  424.         PushVal(GetWord)
  425.  
  426. #ifdef CRAY
  427.         opnd = (word)(strcons + GetWord);
  428. #else                    /* CRAY */
  429.         opnd = (word)strcons + GetWord;
  430. #endif                    /* CRAY */
  431.  
  432.         PutWord(opnd);
  433.         PushAVal(opnd);
  434.         break;
  435.  
  436.      case Op_Astr:        /* string, absolute address */
  437.         PushVal(GetWord);
  438.         PushAVal(GetWord);
  439.         break;
  440.  
  441.                 /* ---Variable construction--- */
  442.  
  443.      case Op_Arg:        /* argument */
  444.         PushVal(D_Var);
  445.         PushAVal(&argp[GetWord + 1]);
  446.         break;
  447.  
  448.      case Op_Global:    /* global */
  449.         PutOp(Op_Aglobal);
  450.         PushVal(D_Var);
  451.         opnd = GetWord;
  452.         PushAVal(&globals[opnd]);
  453.         PutWord((word)&globals[opnd]);
  454.         break;
  455.  
  456.      case Op_Aglobal:    /* global, absolute address */
  457.         PushVal(D_Var);
  458.         PushAVal(GetWord);
  459.         break;
  460.  
  461.      case Op_Local:     /* local */
  462.         PushVal(D_Var);
  463.         PushAVal(&pfp->pf_locals[GetWord]);
  464.         break;
  465.  
  466.      case Op_Static:    /* static */
  467.         PutOp(Op_Astatic);
  468.         PushVal(D_Var);
  469.         opnd = GetWord;
  470.         PushAVal(&statics[opnd]);
  471.         PutWord((word)&statics[opnd]);
  472.         break;
  473.  
  474.      case Op_Astatic:    /* static, absolute address */
  475.         PushVal(D_Var);
  476.         PushAVal(GetWord);
  477.         break;
  478.  
  479.  
  480.                 /* ---Operators--- */
  481.  
  482.                 /* Unary operators */
  483.  
  484.      case Op_Compl:     /* ~e */
  485.      case Op_Neg:        /* -e */
  486.      case Op_Number:    /* +e */
  487.      case Op_Refresh:    /* ^e */
  488.      case Op_Size:        /* *e */
  489.         Setup_Op(1);
  490.         DerefArg(1);
  491.         Call_Cond;
  492.  
  493.      case Op_Value:     /* .e */
  494.             Setup_Op(1);
  495.             DerefArg(1);
  496.             Call_Cond;
  497.  
  498.      case Op_Nonnull:    /* \e */
  499.      case Op_Null:        /* /e */
  500.         Setup_Op(1);
  501.         Call_Cond;
  502.  
  503.      case Op_Random:    /* ?e */
  504.         PushNull;
  505.         Setup_Op(2)
  506.         Call_Cond
  507.  
  508.                 /* Generative unary operators */
  509.  
  510.      case Op_Tabmat:    /* =e */
  511.         Setup_Op(1);
  512.         DerefArg(1);
  513.         Call_Gen;
  514.  
  515.      case Op_Bang:        /* !e */
  516.         PushNull;
  517.         Setup_Op(2);
  518.         Call_Gen;
  519.  
  520.                 /* Binary operators */
  521.  
  522.      case Op_Cat:        /* e1 || e2 */
  523.      case Op_Diff:        /* e1 -- e2 */
  524.      case Op_Div:        /* e1 / e2 */
  525.      case Op_Inter:     /* e1 ** e2 */
  526.      case Op_Lconcat:    /* e1 ||| e2 */
  527.      case Op_Minus:     /* e1 - e2 */
  528.      case Op_Mod:        /* e1 % e2 */
  529.      case Op_Mult:        /* e1 * e2 */
  530.      case Op_Power:     /* e1 ^ e2 */
  531.      case Op_Unions:    /* e1 ++ e2 */
  532.      case Op_Plus:        /* e1 + e2 */
  533.      case Op_Eqv:        /* e1 === e2 */
  534.      case Op_Lexeq:     /* e1 == e2 */
  535.      case Op_Lexge:     /* e1 >>= e2 */
  536.      case Op_Lexgt:     /* e1 >> e2 */
  537.      case Op_Lexle:     /* e1 <<= e2 */
  538.      case Op_Lexlt:     /* e1 << e2 */
  539.      case Op_Lexne:     /* e1 ~== e2 */
  540.      case Op_Neqv:        /* e1 ~=== e2 */
  541.      case Op_Numeq:     /* e1 = e2 */
  542.      case Op_Numge:     /* e1 >= e2 */
  543.      case Op_Numgt:     /* e1 > e2 */
  544.      case Op_Numle:     /* e1 <= e2 */
  545.      case Op_Numne:     /* e1 ~= e2 */
  546.      case Op_Numlt:     /* e1 < e2 */
  547.         Setup_Op(2);
  548.         DerefArg(1);
  549.         DerefArg(2);
  550.         Call_Cond;
  551.  
  552.      case Op_Asgn:        /* e1 := e2 */
  553.         Setup_Op(2);
  554.         DerefArg(2);
  555.         Call_Cond;
  556.  
  557.      case Op_Swap:        /* e1 :=: e2 */
  558.         PushNull;
  559.         Setup_Op(3);
  560.         Call_Cond;
  561.  
  562.      case Op_Subsc:     /* e1[e2] */
  563.         PushNull;
  564.         Setup_Op(3);
  565.         DerefArg(2);
  566.         Call_Cond;
  567.                 /* Generative binary operators */
  568.  
  569.      case Op_Rasgn:     /* e1 <- e2 */
  570.         Setup_Op(2);
  571.         DerefArg(2);
  572.         Call_Gen;
  573.  
  574.      case Op_Rswap:     /* e1 <-> e2 */
  575.         PushNull;
  576.         Setup_Op(3);
  577.         Call_Gen;
  578.  
  579.                 /* Conditional ternary operators */
  580.  
  581.      case Op_Sect:        /* e1[e2:e3] */
  582.         PushNull;
  583.         Setup_Op(4);
  584.         DerefArg(2);
  585.         DerefArg(3);
  586.         Call_Cond;
  587.                 /* Generative ternary operators */
  588.  
  589.      case Op_Toby:        /* e1 to e2 by e3 */
  590.         Setup_Op(3);
  591.         DerefArg(1);
  592.         DerefArg(2);
  593.         DerefArg(3);
  594.         Call_Gen;
  595.  
  596.          case Op_Noop:        /* no-op */
  597.  
  598. #ifdef LineCodes
  599. #ifdef Polling
  600.             if (!pollctr--) {
  601.            ExInterp;
  602.                pollctr = pollevent();
  603.            EntInterp;
  604.            if (pollctr == -1) fatalerr(141, NULL);
  605.            }           
  606. #endif                    /* Polling */
  607.  
  608.  
  609. #endif                /* LineCodes */
  610.  
  611.             break;
  612.  
  613.  
  614.          case Op_Colm:        /* source column number */
  615.  
  616. #ifdef EventMon
  617.             column = GetWord;
  618.             if (column != lastcol) {
  619.                InterpEVVal(column,E_Colm);
  620.                lastcol = column;
  621.                }
  622. #endif                    /* EventMon */
  623.  
  624.             break;
  625.  
  626.          case Op_Line:        /* source line number */
  627.  
  628. #ifdef LineCodes
  629. #ifdef Polling
  630.             if (!pollctr--) {
  631.            ExInterp;
  632.                pollctr = pollevent();
  633.            EntInterp;
  634.            if (pollctr == -1) fatalerr(141, NULL);
  635.            }           
  636. #endif                    /* Polling */
  637.  
  638.  
  639. #endif                /* LineCodes */
  640.  
  641. #ifdef EventMon
  642.             linenum = GetWord;
  643.             if (linenum != lastline) {
  644.                InterpEVVal(linenum,E_Line);
  645.                lastline = linenum;
  646.                }
  647. #endif                    /* EventMon */
  648.  
  649.             break;
  650.  
  651.                 /* ---String Scanning--- */
  652.  
  653.      case Op_Bscan:     /* prepare for scanning */
  654.         PushDesc(k_subject);
  655.         PushVal(D_Integer);
  656.         PushVal(k_pos);
  657.         Setup_Op(2);
  658.  
  659.         signal = Obscan(2,rargp);
  660.  
  661.         goto C_rtn_term;
  662.  
  663.      case Op_Escan:     /* exit from scanning */
  664.         Setup_Op(1);
  665.  
  666.         signal = Oescan(1,rargp);
  667.  
  668.         goto C_rtn_term;
  669.  
  670.                 /* ---Other Language Operations--- */
  671.  
  672.  
  673.          case Op_Apply: {    /* apply */
  674.             {
  675.             union block *bp;
  676.             int i, j;
  677.  
  678.             value_tmp = *(dptr)(rsp - 1);    /* argument */
  679.             Deref(value_tmp);
  680.             if (value_tmp.dword != D_List) {    /* be sure it's a list */
  681.                xargp = (dptr)(rsp - 3);
  682.                err_msg(108, &value_tmp);
  683.                goto efail;
  684.                } 
  685.             rsp -= 2;                /* pop it off */
  686.             bp = BlkLoc(value_tmp);
  687.             args = (int)bp->list.size;
  688.             for (bp = bp->list.listhead; bp != NULL; bp = bp->lelem.listnext) {
  689.                for (i = 0; i < bp->lelem.nused; i++) {
  690.                   j = bp->lelem.first + i;
  691.                   if (j >= bp->lelem.nslots)
  692.                      j -= bp->lelem.nslots;
  693.                   PushDesc(bp->lelem.lslots[j])
  694.                   }
  695.                }
  696.             goto invokej;
  697.                }
  698.             }
  699.  
  700.      case Op_Invoke: {    /* invoke */
  701.             args = (int)GetWord;
  702. invokej:
  703.         {
  704.             int nargs;
  705.         dptr carg;
  706.  
  707.         ExInterp;
  708.         type = invoke(args, &carg, &nargs);
  709.         rargp = carg;
  710.         EntInterp;
  711.  
  712. #ifdef MaxLevel
  713.         if (k_level > maxplevel)
  714.            maxplevel = k_level;
  715. #endif                    /* MaxLevel */
  716.  
  717.         if (type == I_Fail)
  718.            goto efail;
  719.         if (type == I_Continue)
  720.            break;
  721.         else {
  722.  
  723.            bproc = (struct b_proc *)BlkLoc(*rargp);
  724.  
  725.            /* ExInterp not needed since no change since last EntInterp */
  726.            if (type == I_Vararg) {
  727.               int (*bfunc)();
  728.               bfunc = bproc->entryp.ccode;
  729.  
  730.           signal = (*bfunc)(nargs,rargp);
  731.  
  732.                   }
  733.            else
  734.                   {
  735.               int (*bfunc)();
  736.               bfunc = bproc->entryp.ccode;
  737.  
  738.           signal = (*bfunc)(rargp);
  739.                   }
  740.  
  741.  
  742.            goto C_rtn_term;
  743.            }
  744.         }
  745.         break;
  746.         }
  747.  
  748.      case Op_Keywd:     /* keyword */
  749.  
  750.             PushNull;
  751.             opnd = GetWord;
  752.             Setup_Op(0);
  753.  
  754.  
  755.         signal = (*(keytab[(int)opnd]))(rargp);
  756.         goto C_rtn_term;
  757.  
  758.      case Op_Llist:     /* construct list */
  759.         opnd = GetWord;
  760.         Setup_Op(opnd);
  761.         {
  762.         int i;
  763.         for (i=1;i<=opnd;i++)
  764.                DerefArg(i);
  765.         }
  766.  
  767.         signal = Ollist((int)opnd,rargp);
  768.  
  769.         goto C_rtn_term;
  770.  
  771.                 /* ---Marking and Unmarking--- */
  772.  
  773.      case Op_Mark:        /* create expression frame marker */
  774.         PutOp(Op_Amark);
  775.         opnd = GetWord;
  776.         opnd += (word)ipc.opnd;
  777.         PutWord(opnd);
  778.         newefp = (struct ef_marker *)(rsp + 1);
  779.         newefp->ef_failure.opnd = (word *)opnd;
  780.         goto mark;
  781.  
  782.      case Op_Amark:     /* mark with absolute fipc */
  783.         newefp = (struct ef_marker *)(rsp + 1);
  784.         newefp->ef_failure.opnd = (word *)GetWord;
  785. mark:
  786.         newefp->ef_gfp = gfp;
  787.         newefp->ef_efp = efp;
  788.         newefp->ef_ilevel = ilevel;
  789.         rsp += Wsizeof(*efp);
  790.         efp = newefp;
  791.         gfp = 0;
  792.         break;
  793.  
  794.      case Op_Mark0:     /* create expression frame with 0 ipl */
  795. mark0:
  796.         newefp = (struct ef_marker *)(rsp + 1);
  797.         newefp->ef_failure.opnd = 0;
  798.         newefp->ef_gfp = gfp;
  799.         newefp->ef_efp = efp;
  800.         newefp->ef_ilevel = ilevel;
  801.         rsp += Wsizeof(*efp);
  802.         efp = newefp;
  803.         gfp = 0;
  804.         break;
  805.  
  806.      case Op_Unmark:    /* remove expression frame */
  807.  
  808. #ifdef EventMon
  809.             vanquish(gfp);
  810. #endif                    /* EventMon */
  811.  
  812.         gfp = efp->ef_gfp;
  813.         rsp = (word *)efp - 1;
  814.  
  815.         /*
  816.          * Remove any suspended C generators.
  817.          */
  818. Unmark_uw:
  819.         if (efp->ef_ilevel < ilevel) {
  820.            --ilevel;
  821.            ExInterp;
  822.            return A_Unmark_uw;
  823.            }
  824.         efp = efp->ef_efp;
  825.         break;
  826.  
  827.                 /* ---Suspensions--- */
  828.  
  829.      case Op_Esusp: {    /* suspend from expression */
  830.  
  831.         /*
  832.          * Create the generator frame.
  833.          */
  834.         oldsp = rsp;
  835.         newgfp = (struct gf_marker *)(rsp + 1);
  836.         newgfp->gf_gentype = G_Esusp;
  837.         newgfp->gf_gfp = gfp;
  838.         newgfp->gf_efp = efp;
  839.         newgfp->gf_ipc = ipc;
  840.         gfp = newgfp;
  841.         rsp += Wsizeof(struct gf_smallmarker);
  842.  
  843.         /*
  844.          * Region extends from first word after enclosing generator or
  845.          *    expression frame marker to marker for current expression frame.
  846.          */
  847.         if (efp->ef_gfp != 0) {
  848.            newgfp = (struct gf_marker *)(efp->ef_gfp);
  849.            if (newgfp->gf_gentype == G_Psusp)
  850.           firstwd = (word *)efp->ef_gfp + Wsizeof(*gfp);
  851.            else
  852.           firstwd = (word *)efp->ef_gfp +
  853.              Wsizeof(struct gf_smallmarker);
  854.         }
  855.         else
  856.            firstwd = (word *)efp->ef_efp + Wsizeof(*efp);
  857.         lastwd = (word *)efp - 1;
  858.         efp = efp->ef_efp;
  859.  
  860.         /*
  861.          * Copy the portion of the stack with endpoints firstwd and lastwd
  862.          *    (inclusive) to the top of the stack.
  863.          */
  864.         for (wd = firstwd; wd <= lastwd; wd++)
  865.            *++rsp = *wd;
  866.         PushVal(oldsp[-1]);
  867.         PushVal(oldsp[0]);
  868.         break;
  869.         }
  870.  
  871.      case Op_Lsusp: {    /* suspend from limitation */
  872.         struct descrip sval;
  873.  
  874.         /*
  875.          * The limit counter is contained in the descriptor immediately
  876.          *    prior to the current expression frame.    lval is established
  877.          *    as a pointer to this descriptor.
  878.          */
  879.         dptr lval = (dptr)((word *)efp - 2);
  880.  
  881.         /*
  882.          * Decrement the limit counter and check it.
  883.          */
  884.         if (--IntVal(*lval) > 0) {
  885.            /*
  886.         * The limit has not been reached, set up stack.
  887.         */
  888.  
  889.            sval = *(dptr)(rsp - 1);    /* save result */
  890.  
  891.            /*
  892.         * Region extends from first word after enclosing generator or
  893.         *  expression frame marker to the limit counter just prior to
  894.         *  to the current expression frame marker.
  895.         */
  896.            if (efp->ef_gfp != 0) {
  897.           newgfp = (struct gf_marker *)(efp->ef_gfp);
  898.           if (newgfp->gf_gentype == G_Psusp)
  899.              firstwd = (word *)efp->ef_gfp + Wsizeof(*gfp);
  900.           else
  901.              firstwd = (word *)efp->ef_gfp +
  902.             Wsizeof(struct gf_smallmarker);
  903.           }
  904.            else
  905.           firstwd = (word *)efp->ef_efp + Wsizeof(*efp);
  906.            lastwd = (word *)efp - 3;
  907.            if (gfp == 0)
  908.           gfp = efp->ef_gfp;
  909.            efp = efp->ef_efp;
  910.  
  911.            /*
  912.         * Copy the portion of the stack with endpoints firstwd and lastwd
  913.         *  (inclusive) to the top of the stack.
  914.         */
  915.            rsp -= 2;        /* overwrite result */
  916.            for (wd = firstwd; wd <= lastwd; wd++)
  917.           *++rsp = *wd;
  918.            PushDesc(sval);        /* push saved result */
  919.            }
  920.         else {
  921.            /*
  922.         * Otherwise, the limit has been reached.  Instead of
  923.         *  suspending, remove the current expression frame and
  924.         *  replace the limit counter with the value on top of
  925.         *  the stack (which would have been suspended had the
  926.         *  limit not been reached).
  927.         */
  928.            *lval = *(dptr)(rsp - 1);
  929.  
  930. #ifdef EventMon
  931.                vanquish(gfp);
  932. #endif                    /* EventMon */
  933.  
  934.            gfp = efp->ef_gfp;
  935.  
  936.            /*
  937.         * Since an expression frame is being removed, inactive
  938.         *  C generators contained therein are deactivated.
  939.         */
  940. Lsusp_uw:
  941.            if (efp->ef_ilevel < ilevel) {
  942.           --ilevel;
  943.           ExInterp;
  944.           return A_Lsusp_uw;
  945.           }
  946.            rsp = (word *)efp - 1;
  947.            efp = efp->ef_efp;
  948.            }
  949.         break;
  950.         }
  951.  
  952.      case Op_Psusp: {    /* suspend from procedure */
  953.  
  954.         /*
  955.          * An Icon procedure is suspending a value.  Determine if the
  956.          *    value being suspended should be dereferenced and if so,
  957.          *    dereference it. If tracing is on, strace is called
  958.          *  to generate a message.  Appropriate values are
  959.          *    restored from the procedure frame of the suspending procedure.
  960.          */
  961.  
  962.         struct descrip tmp;
  963.             dptr svalp;
  964.         struct b_proc *sproc;
  965.  
  966. #ifdef EventMon
  967.             InterpEVValD(argp,E_Psusp);
  968. #endif                    /* EventMon */
  969.  
  970.         svalp = (dptr)(rsp - 1);
  971.         if (Var(*svalp)) {
  972.                ExInterp;
  973.                retderef(svalp, svalp, (word *)StackBase(k_current));
  974.                EntInterp;
  975.                }
  976.  
  977.         /*
  978.          * Create the generator frame.
  979.          */
  980.         oldsp = rsp;
  981.         newgfp = (struct gf_marker *)(rsp + 1);
  982.         newgfp->gf_gentype = G_Psusp;
  983.         newgfp->gf_gfp = gfp;
  984.         newgfp->gf_efp = efp;
  985.         newgfp->gf_ipc = ipc;
  986.         newgfp->gf_argp = argp;
  987.         newgfp->gf_pfp = pfp;
  988.         gfp = newgfp;
  989.         rsp += Wsizeof(*gfp);
  990.  
  991.         /*
  992.          * Region extends from first word after the marker for the
  993.          *    generator or expression frame enclosing the call to the
  994.          *    now-suspending procedure to Arg0 of the procedure.
  995.          */
  996.         if (pfp->pf_gfp != 0) {
  997.            newgfp = (struct gf_marker *)(pfp->pf_gfp);
  998.            if (newgfp->gf_gentype == G_Psusp)
  999.           firstwd = (word *)pfp->pf_gfp + Wsizeof(*gfp);
  1000.            else
  1001.           firstwd = (word *)pfp->pf_gfp +
  1002.              Wsizeof(struct gf_smallmarker);
  1003.            }
  1004.         else
  1005.            firstwd = (word *)pfp->pf_efp + Wsizeof(*efp);
  1006.         lastwd = (word *)argp - 1;
  1007.            efp = efp->ef_efp;
  1008.  
  1009.         /*
  1010.          * Copy the portion of the stack with endpoints firstwd and lastwd
  1011.          *    (inclusive) to the top of the stack.
  1012.          */
  1013.         for (wd = firstwd; wd <= lastwd; wd++)
  1014.            *++rsp = *wd;
  1015.         PushVal(oldsp[-1]);
  1016.         PushVal(oldsp[0]);
  1017.         --k_level;
  1018.         if (k_trace) {
  1019.                k_trace--;
  1020.            sproc = (struct b_proc *)BlkLoc(*argp);
  1021.            strace(&(sproc->pname), svalp);
  1022.            }
  1023.  
  1024.         /*
  1025.          * If the scanning environment for this procedure call is in
  1026.          *    a saved state, switch environments.
  1027.          */
  1028.         if (pfp->pf_scan != NULL) {
  1029.            tmp = k_subject;
  1030.            k_subject = *pfp->pf_scan;
  1031.            *pfp->pf_scan = tmp;
  1032.  
  1033.            tmp = *(pfp->pf_scan + 1);
  1034.            IntVal(*(pfp->pf_scan + 1)) = k_pos;
  1035.            k_pos = IntVal(tmp);
  1036.            }
  1037.  
  1038.  
  1039.         efp = pfp->pf_efp;
  1040.         ipc = pfp->pf_ipc;
  1041.         argp = pfp->pf_argp;
  1042.         pfp = pfp->pf_pfp;
  1043.         break;
  1044.         }
  1045.  
  1046.                 /* ---Returns--- */
  1047.  
  1048.      case Op_Eret: {    /* return from expression */
  1049.         /*
  1050.          * Op_Eret removes the current expression frame, leaving the
  1051.          *    original top of stack value on top.
  1052.          */
  1053.         /*
  1054.          * Save current top of stack value in global temporary (no
  1055.          *    danger of reentry).
  1056.          */
  1057.         eret_tmp = *(dptr)&rsp[-1];
  1058.         gfp = efp->ef_gfp;
  1059. Eret_uw:
  1060.         /*
  1061.          * Since an expression frame is being removed, inactive
  1062.          *    C generators contained therein are deactivated.
  1063.          */
  1064.         if (efp->ef_ilevel < ilevel) {
  1065.            --ilevel;
  1066.            ExInterp;
  1067.            return A_Eret_uw;
  1068.            }
  1069.         rsp = (word *)efp - 1;
  1070.         efp = efp->ef_efp;
  1071.         PushDesc(eret_tmp);
  1072.         break;
  1073.         }
  1074.  
  1075.  
  1076.      case Op_Pret: {    /* return from procedure */
  1077.        struct descrip oldargp;
  1078.  
  1079.         /*
  1080.          * An Icon procedure is returning a value.    Determine if the
  1081.          *    value being returned should be dereferenced and if so,
  1082.          *    dereference it.  If tracing is on, rtrace is called to
  1083.          *    generate a message.  Inactive generators created after
  1084.          *    the activation of the procedure are deactivated.  Appropriate
  1085.          *    values are restored from the procedure frame.
  1086.          */
  1087.         struct b_proc *rproc = (struct b_proc *)BlkLoc(*argp);
  1088.  
  1089. #ifdef EventMon
  1090.             vanquish(gfp);
  1091.             InterpEVValD(argp,E_Pret);
  1092. #endif                    /* EventMon */
  1093.  
  1094.         *argp = *(dptr)(rsp - 1);
  1095.         if (Var(*argp)) {
  1096.                ExInterp;
  1097.                retderef(argp, argp, (word *)StackBase(k_current));
  1098.                EntInterp;
  1099.                }
  1100.  
  1101.         --k_level;
  1102.         if (k_trace) {
  1103.                k_trace--;
  1104.            rtrace(&(rproc->pname), argp);
  1105.                }
  1106. Pret_uw:
  1107.         if (pfp->pf_ilevel < ilevel) {
  1108.            --ilevel;
  1109.            ExInterp;
  1110.            return A_Pret_uw;
  1111.            }
  1112.         rsp = (word *)argp + 1;
  1113.         efp = pfp->pf_efp;
  1114.         gfp = pfp->pf_gfp;
  1115.         ipc = pfp->pf_ipc;
  1116.         argp = pfp->pf_argp;
  1117.         pfp = pfp->pf_pfp;
  1118.  
  1119.  
  1120. #ifdef EventMon
  1121.             goto return_term;
  1122. #else                    /* EventMon */
  1123.         break;
  1124. #endif                    /* EventMon */
  1125.  
  1126.         }
  1127.  
  1128.                 /* ---Failures--- */
  1129.  
  1130.      case Op_Efail:
  1131. efail:
  1132. #ifdef EventMon
  1133.             InterpEVVal((word)-1,E_Efail);
  1134. #endif                    /* EventMon */
  1135.         /*
  1136.          * Failure has occurred in the current expression frame.
  1137.          */
  1138.         if (gfp == 0) {
  1139.            /*
  1140.         * There are no suspended generators to resume.
  1141.         *  Remove the current expression frame, restoring
  1142.         *  values.
  1143.         *
  1144.         * If the failure ipc is 0, propagate failure to the
  1145.         *  enclosing frame by branching back to efail.
  1146.         *  This happens, for example, in looping control
  1147.         *  structures that fail when complete.
  1148.         */
  1149.  
  1150.  
  1151.            ipc = efp->ef_failure;
  1152.            gfp = efp->ef_gfp;
  1153.            rsp = (word *)efp - 1;
  1154.            efp = efp->ef_efp;
  1155.  
  1156.            if (ipc.op == 0)
  1157.           goto efail;
  1158.            break;
  1159.            }
  1160.  
  1161.         else {
  1162.            /*
  1163.         * There is a generator that can be resumed.  Make
  1164.         *  the stack adjustments and then switch on the
  1165.         *  type of the generator frame marker.
  1166.         */
  1167.            struct descrip tmp;
  1168.            register struct gf_marker *resgfp = gfp;
  1169.  
  1170.            type = (int)resgfp->gf_gentype;
  1171.  
  1172.  
  1173.            if (type == G_Psusp) {
  1174.           argp = resgfp->gf_argp;
  1175.           if (k_trace) {    /* procedure tracing */
  1176.                      k_trace--;
  1177.              ExInterp;
  1178.              atrace(&(((struct b_proc *)BlkLoc(*argp))->pname));
  1179.              EntInterp;
  1180.              }
  1181.           }
  1182.            ipc = resgfp->gf_ipc;
  1183.            efp = resgfp->gf_efp;
  1184.            gfp = resgfp->gf_gfp;
  1185.            rsp = (word *)resgfp - 1;
  1186.            if (type == G_Psusp) {
  1187.           pfp = resgfp->gf_pfp;
  1188.  
  1189.           /*
  1190.            * If the scanning environment for this procedure call is
  1191.            *  supposed to be in a saved state, switch environments.
  1192.            */
  1193.           if (pfp->pf_scan != NULL) {
  1194.              tmp = k_subject;
  1195.              k_subject = *pfp->pf_scan;
  1196.              *pfp->pf_scan = tmp;
  1197.  
  1198.              tmp = *(pfp->pf_scan + 1);
  1199.              IntVal(*(pfp->pf_scan + 1)) = k_pos;
  1200.              k_pos = IntVal(tmp);
  1201.              }
  1202.  
  1203.  
  1204.           ++k_level;        /* adjust procedure level */
  1205.           }
  1206.  
  1207.            switch (type) {
  1208.  
  1209.           case G_Csusp: {
  1210.  
  1211. #ifdef EventMon
  1212.                      InterpEVVal((word)0,E_Eresum);
  1213. #endif                    /* EventMon */
  1214.  
  1215.              --ilevel;
  1216.              ExInterp;
  1217.              return A_Resume;
  1218.              break;
  1219.              }
  1220.  
  1221.           case G_Esusp:
  1222.  
  1223. #ifdef EventMon
  1224.                      InterpEVVal((word)0,E_Eresum);
  1225. #endif                    /* EventMon */
  1226.  
  1227.              goto efail;
  1228.  
  1229.           case G_Psusp:        /* resuming a procedure */
  1230.  
  1231. #ifdef EventMon
  1232.                      InterpEVValD(argp,E_Presum);
  1233. #endif                    /* EventMon */
  1234.              break;
  1235.           }
  1236.  
  1237.            break;
  1238.            }
  1239.  
  1240.      case Op_Pfail: {    /* fail from procedure */
  1241.  
  1242. #ifdef EventMon
  1243.             vanquish(gfp);
  1244.             EVValD(argp,E_Pfail);
  1245.         EntInterp;
  1246. #endif                    /* EventMon */
  1247.  
  1248.         /*
  1249.          * An Icon procedure is failing.  Generate tracing message if
  1250.          *    tracing is on.    Deactivate inactive C generators created
  1251.          *    after activation of the procedure.  Appropriate values
  1252.          *    are restored from the procedure frame.
  1253.          */
  1254.  
  1255.         --k_level;
  1256.         if (k_trace) {
  1257.                k_trace--;
  1258.            failtrace(&(((struct b_proc *)BlkLoc(*argp))->pname));
  1259.                }
  1260. Pfail_uw:
  1261.  
  1262.         if (pfp->pf_ilevel < ilevel) {
  1263.            --ilevel;
  1264.            ExInterp;
  1265.            return A_Pfail_uw;
  1266.            }
  1267.         efp = pfp->pf_efp;
  1268.         gfp = pfp->pf_gfp;
  1269.         ipc = pfp->pf_ipc;
  1270.         argp = pfp->pf_argp;
  1271.         pfp = pfp->pf_pfp;
  1272.  
  1273.  
  1274.         goto efail;
  1275.         }
  1276.                 /* ---Odds and Ends--- */
  1277.  
  1278.      case Op_Ccase:     /* case clause */
  1279.         PushNull;
  1280.         PushVal(((word *)efp)[-2]);
  1281.         PushVal(((word *)efp)[-1]);
  1282.         break;
  1283.  
  1284.      case Op_Chfail:    /* change failure ipc */
  1285.         opnd = GetWord;
  1286.         opnd += (word)ipc.opnd;
  1287.         efp->ef_failure.opnd = (word *)opnd;
  1288.         break;
  1289.  
  1290.      case Op_Dup:        /* duplicate descriptor */
  1291.         PushNull;
  1292.         rsp[1] = rsp[-3];
  1293.         rsp[2] = rsp[-2];
  1294.         rsp += 2;
  1295.         break;
  1296.  
  1297.      case Op_Field:     /* e1.e2 */
  1298.         PushVal(D_Integer);
  1299.         PushVal(GetWord);
  1300.         Setup_Op(2);
  1301.  
  1302.         signal = Ofield(2,rargp);
  1303.  
  1304.         goto C_rtn_term;
  1305.  
  1306.      case Op_Goto:        /* goto */
  1307.         PutOp(Op_Agoto);
  1308.         opnd = GetWord;
  1309.         opnd += (word)ipc.opnd;
  1310.         PutWord(opnd);
  1311.         ipc.opnd = (word *)opnd;
  1312.         break;
  1313.  
  1314.      case Op_Agoto:     /* goto absolute address */
  1315.         opnd = GetWord;
  1316.         ipc.opnd = (word *)opnd;
  1317.         break;
  1318.  
  1319.      case Op_Init:        /* initial */
  1320.         *--ipc.op = Op_Goto;
  1321.  
  1322. #ifdef CRAY
  1323.         opnd = (sizeof(*ipc.op) + sizeof(*rsp))/8;
  1324. #else                    /* CRAY */
  1325.         opnd = sizeof(*ipc.op) + sizeof(*rsp);
  1326. #endif                    /* CRAY */
  1327.  
  1328.         opnd += (word)ipc.opnd;
  1329.         ipc.opnd = (word *)opnd;
  1330.         break;
  1331.  
  1332.      case Op_Limit:     /* limit */
  1333.         Setup_Op(0);
  1334.  
  1335.         if (Olimit(0,rargp) == A_Resume)
  1336.  
  1337.            goto efail;
  1338.         else
  1339.            rsp = (word *) rargp + 1;
  1340.         goto mark0;
  1341.  
  1342. #ifdef TallyOpt
  1343.      case Op_Tally:     /* tally */
  1344.         tallybin[GetWord]++;
  1345.         break;
  1346. #endif                    /* TallyOpt */
  1347.  
  1348.      case Op_Pnull:     /* push null descriptor */
  1349.         PushNull;
  1350.         break;
  1351.  
  1352.      case Op_Pop:        /* pop descriptor */
  1353.         rsp -= 2;
  1354.         break;
  1355.  
  1356.      case Op_Push1:     /* push integer 1 */
  1357.         PushVal(D_Integer);
  1358.         PushVal(1);
  1359.         break;
  1360.  
  1361.      case Op_Pushn1:    /* push integer -1 */
  1362.         PushVal(D_Integer);
  1363.         PushVal(-1);
  1364.         break;
  1365.  
  1366.      case Op_Sdup:        /* duplicate descriptor */
  1367.         rsp += 2;
  1368.         rsp[-1] = rsp[-3];
  1369.         rsp[0] = rsp[-2];
  1370.         break;
  1371.  
  1372.                     /* ---Co-expressions--- */
  1373.  
  1374.      case Op_Create:    /* create */
  1375.  
  1376. #ifdef Coexpr
  1377.         PushNull;
  1378.         Setup_Op(0);
  1379.         opnd = GetWord;
  1380.         opnd += (word)ipc.opnd;
  1381.  
  1382.         signal = Ocreate((word *)opnd, rargp);
  1383.  
  1384.         goto C_rtn_term;
  1385. #else                    /* Coexpr */
  1386.         err_msg(401, NULL);
  1387.         goto efail;
  1388. #endif                    /* Coexpr */
  1389.  
  1390.      case Op_Coact: {    /* @e */
  1391.  
  1392. #ifndef Coexpr
  1393.             err_msg(401, NULL);
  1394.             goto efail;
  1395. #else                                        /* Coexpr */
  1396.             struct b_coexpr *ncp;
  1397.             dptr dp;
  1398.  
  1399.             ExInterp;
  1400.             dp = (dptr)(sp - 1);
  1401.  
  1402. #ifdef TraceBack
  1403.             xargp = dp - 2;
  1404. #endif                                                /* TraceBack */
  1405.  
  1406.             Deref(*dp);
  1407.             if (dp->dword != D_Coexpr) {
  1408.                err_msg(118, dp);
  1409.                goto efail;
  1410.                }
  1411.  
  1412.             ncp = (struct b_coexpr *)BlkLoc(*dp);
  1413.  
  1414.             signal = activate((dptr)(sp - 3), ncp, (dptr)(sp - 3));
  1415.             EntInterp;
  1416.             if (signal == A_Resume)
  1417.                goto efail;
  1418.             else
  1419.                rsp -= 2;
  1420. #endif                    /* Coexpr */
  1421.             break;
  1422.         }
  1423.  
  1424.      case Op_Coret: {    /* return from co-expression */
  1425.  
  1426. #ifndef Coexpr
  1427.             syserr("coexpression return, but coexpressions not implemented");
  1428. #else                                        /* Coexpr */
  1429.             struct b_coexpr *ncp;
  1430.  
  1431.             ExInterp;
  1432.             ncp = popact((struct b_coexpr *)BlkLoc(k_current));
  1433.  
  1434.             ++BlkLoc(k_current)->coexpr.size;
  1435.             co_chng(ncp, (dptr)&sp[-1], NULL, A_Coret, 1);
  1436.             EntInterp;
  1437. #endif                    /* Coexpr */
  1438.             break;
  1439.  
  1440.         }
  1441.  
  1442.      case Op_Cofail: {    /* fail from co-expression */
  1443.  
  1444. #ifndef Coexpr
  1445.             syserr("coexpression failure, but coexpressions not implemented");
  1446. #else                                        /* Coexpr */
  1447.             struct b_coexpr *ncp;
  1448.  
  1449.             ExInterp;
  1450.             ncp = popact((struct b_coexpr *)BlkLoc(k_current));
  1451.  
  1452.             co_chng(ncp, NULL, NULL, A_Cofail, 1);
  1453.             EntInterp;
  1454. #endif                    /* Coexpr */
  1455.             break;
  1456.  
  1457.         }
  1458.  
  1459.          case Op_Quit:        /* quit */
  1460.  
  1461. #ifdef IconCalling
  1462.             ExInterp;        /* restores stack pointer for icon_call */
  1463.         interp_status = A_Pret_uw;
  1464. #endif                     /* IconCalling */
  1465.  
  1466.         goto interp_quit;
  1467.  
  1468. #ifdef IconCalling
  1469.          case Op_FQuit:        /* failing quit */
  1470.         ExInterp;        /* restores stack pointer for icon_call */
  1471.         interp_status = A_Pfail_uw;
  1472.             goto interp_quit;
  1473. #endif                     /* IconCalling */
  1474.  
  1475.  
  1476.      default: {
  1477.         char buf[50];
  1478.  
  1479.         sprintf(buf, "unimplemented opcode: %ld (0x%08x)\n",
  1480.                (long)lastop, lastop);
  1481.         syserr(buf);
  1482.         }
  1483.      }
  1484.      continue;
  1485.  
  1486. C_rtn_term:
  1487.      EntInterp;
  1488.      switch (signal) {
  1489.  
  1490.         case A_Resume:
  1491.            goto efail;
  1492.  
  1493.         case A_Unmark_uw:        /* unwind for unmark */
  1494.            goto Unmark_uw;
  1495.  
  1496.         case A_Lsusp_uw:        /* unwind for lsusp */
  1497.            goto Lsusp_uw;
  1498.  
  1499.         case A_Eret_uw:        /* unwind for eret */
  1500.            goto Eret_uw;
  1501.  
  1502.         case A_Pret_uw:        /* unwind for pret */
  1503.            goto Pret_uw;
  1504.  
  1505.         case A_Pfail_uw:        /* unwind for pfail */
  1506.            goto Pfail_uw;
  1507.         }
  1508.  
  1509.      rsp = (word *)rargp + 1;    /* set rsp to result */
  1510.  
  1511. #ifdef EventMon
  1512. return_term:
  1513.          value_tmp = *(dptr)(rsp - 1);    /* argument */
  1514.          Deref(value_tmp);
  1515.          InterpEVValD(&value_tmp,E_Eret);
  1516. #endif                    /* EventMon */
  1517.  
  1518.      continue;
  1519.      }
  1520.  
  1521. interp_quit:
  1522.    --ilevel;
  1523. #ifdef MaxLevel
  1524.    fprintf(stderr,"maximum &level = %d\n",maxplevel);
  1525.    fprintf(stderr,"maximum ilevel = %d\n",maxilevel);
  1526.    fprintf(stderr,"maximum sp = %d\n",(long)maxsp - (long)stack);
  1527.    fflush(stderr);
  1528. #endif                    /* MaxLevel */
  1529.  
  1530. #ifndef IconCalling
  1531.    if (ilevel != 0)
  1532.       syserr("interp: termination with inactive generators.");
  1533. #else
  1534.    if (IDepth == 0 && ilevel != 0)
  1535.       syserr("interp(call in): termination with inactive generators");
  1536. #endif                    /* IconCalling */
  1537.  
  1538.    }
  1539.  
  1540. /*
  1541.  * Dereference non-local variables, variable keywords, and substrings
  1542.  *  of global string-valued variables.
  1543.  */
  1544. novalue retderef(ivalp, ovalp, low)
  1545. dptr ivalp, ovalp;
  1546. word *low;
  1547.    {
  1548.    struct b_tvsubs *tvb;
  1549.    word *loc;
  1550.  
  1551.    if (Type(*ivalp) == T_Tvsubs) {
  1552.       tvb = (struct b_tvsubs *)BlkLoc(*ivalp);
  1553.       loc = (word *)VarLoc(tvb->ssvar);
  1554.       }
  1555.    else
  1556.       loc = (word *)VarLoc(*ivalp) + Offset(*ivalp);
  1557.    if (InRange(low, loc, sp))
  1558.       deref(ivalp, ovalp);
  1559.    }
  1560.  
  1561. #ifdef StackPic
  1562. /*
  1563.  * The following code is operating-system dependent [@interp.04].
  1564.  *  Diagnostic stack pictures for debugging/monitoring.
  1565.  */
  1566.  
  1567. #if PORT
  1568. Deliberate Syntax Error
  1569. #endif                    /* PORT */
  1570.  
  1571. #if AMIGA || ATARI_ST || MACINTOSH || MVS || VM || VMS
  1572.    /* not included */
  1573. #endif                    /* AMIGA || ATARI_ST || ... */
  1574.  
  1575. #if ARM
  1576. novalue stkdump(op)
  1577.    int op;
  1578.    {
  1579.    word *stk;
  1580.    word *i;
  1581.    stk = (word *)BlkLoc(k_current);
  1582.    stk += Wsizeof(struct b_coexpr);
  1583.    fprintf(stderr,">  stack:  %.8x\n", (word)stk);
  1584.    fprintf(stderr,">  sp:     %.8x\n", (word)sp);
  1585.    fprintf(stderr,">  pfp:    %.8x\n", (word)pfp);
  1586.    fprintf(stderr,">  efp:    %.8x\n", (word)efp);
  1587.    fprintf(stderr,">  gfp:    %.8x\n", (word)gfp);
  1588.    fprintf(stderr,">  ipc:    %.8x\n", (word)ipc.op);
  1589.    fprintf(stderr,">  argp:   %.8x\n", (word)argp);
  1590.    fprintf(stderr,">  ilevel: %.8x\n", (word)ilevel);
  1591.    fprintf(stderr,">  op:     %d\n",    (int)op);
  1592.    for (i = stk; i <= (word *)sp; i++)
  1593.       fprintf(stderr,"> %.8x\n",(word)*i);
  1594.    fprintf(stderr,"> ----------\n");
  1595.    fflush(stderr);
  1596.    }
  1597. #endif                    /* ARM */
  1598.  
  1599. #if MSDOS || OS2
  1600. #if MICROSOFT || TURBO
  1601. novalue stkdump(op)
  1602.    int op;
  1603.    {
  1604.    word far *stk;
  1605.    word far *i;
  1606.    stk = (word far *)BlkLoc(k_current);
  1607.    stk += Wsizeof(struct b_coexpr);
  1608.    fprintf(stderr,">  stack:  %08lx\n", (word)stk);
  1609.    fprintf(stderr,">  sp:     %08lx\n", (word)sp);
  1610.    fprintf(stderr,">  pfp:    %08lx\n", (word)pfp);
  1611.    fprintf(stderr,">  efp:    %08lx\n", (word)efp);
  1612.    fprintf(stderr,">  gfp:    %08lx\n", (word)gfp);
  1613.    fprintf(stderr,">  ipc:    %08lx\n", (word)ipc.op);
  1614.    fprintf(stderr,">  argp:   %08lx\n", (word)argp);
  1615.    fprintf(stderr,">  ilevel: %08lx\n", (word)ilevel);
  1616.    fprintf(stderr,">  op:     %d\n",    (int)op);
  1617.    for (i = stk; i <= (word far *)sp; i++)
  1618.       fprintf(stderr,"> %08lx\n",(word)*i);
  1619.    fprintf(stderr,"> ----------\n");
  1620.    fflush(stderr);
  1621.    }
  1622. #endif                    /* MICROSOFT || TURBO */
  1623. #endif                    /* MSDOS || OS2 */
  1624.  
  1625. #if UNIX || VMS
  1626. novalue stkdump(op)
  1627.    int op;
  1628.    {
  1629.    word *i;
  1630.    fprintf(stderr,"\001stack: %lx\n",(long)(stack + Wsizeof(struct b_coexpr)));
  1631.    fprintf(stderr,"\001pfp: %lx\n",(long)pfp);
  1632.    fprintf(stderr,"\001efp: %lx\n",(long)efp);
  1633.    fprintf(stderr,"\001gfp: %lx\n",(long)gfp);
  1634.    fprintf(stderr,"\001ipc: %lx\n",(long)ipc.op);
  1635.    fprintf(stderr,"\001argp: %lx\n",(long)argp);
  1636.    fprintf(stderr,"\001ilevel: %lx\n",(long)ilevel);
  1637.    fprintf(stderr,"\001op: \%d\n",(int)op);
  1638.    for (i = stack + Wsizeof(struct b_coexpr); i <= sp; i++)
  1639.       fprintf(stderr,"\001%lx\n",*i);
  1640.    fprintf(stderr,"\001----------\n");
  1641.    fflush(stderr);
  1642.    }
  1643. #endif                    /* UNIX || VMS */
  1644.  
  1645. /*
  1646.  * End of operating-system specific code.
  1647.  */
  1648. #endif                    /* StackPic */
  1649.  
  1650. #ifdef EventMon
  1651. /*
  1652.  * vanquish - monitor the removal of suspended operations.
  1653.  */
  1654. novalue vanquish(gfp)
  1655.    struct gf_marker *gfp;
  1656.  
  1657.    {
  1658.    if (!EventStream)
  1659.       return;
  1660.    while (gfp != 0) {        /* note removal of suspended procedures */
  1661.       if (((int)gfp->gf_gentype) == G_Psusp) {
  1662.          EVValD(gfp->gf_argp,E_Pvan);
  1663.          vanquish(gfp->gf_pfp->pf_gfp);
  1664.          }
  1665.       else
  1666.          EVVal((word)0,E_Evan);
  1667.       gfp = gfp->gf_gfp;
  1668.       }
  1669.    }
  1670. #endif                    /* EventMon */
  1671.  
  1672. #endif                    /* !COMPILER */
  1673.